Shareware Grab Bag/Shareware Grab Bag.iso/050/powertb.arc/TREEDIRS.INC

Text File | 1985-02-24 | 5.0 KB | 210 lines

{ Turbo Pascal routines for tree-structured directories
  Copywrite 1984 Michael A. Covington }

{ Requires MS-DOS or PC-DOS 2.0 or higher, except as noted. }

{ All routines require these type definitions.
  However, except as noted, they do not require each other. }

type pathtype  = string[63];
     drivetype = string[2];
     rtype     = record
                    ax,bx,cx,dx,bp,si,di,ds,es,flags : integer
                    end;

{===============================}
procedure xxdiskerr(x:drivetype);
{===============================}
begin
   writeln('Error -- Invalid disk drive, ''',x,'''');
   halt
end;

{==============================}
procedure xxpatherr(x:pathtype);
{==============================}
begin
   writeln('Error -- Invalid path, ''',x,'''');
   halt
end;

{===============================}
function currentdrive: drivetype;
{===============================}

{ Return designator for current default drive, e.g. 'A:'. }
{ Works under DOS version 1. }

var w  : drivetype;
   reg : rtype;
begin
   reg.ax := $1900;
   intr($21,reg);
   w := 'A:';
   w[1] := chr(ord(w[1])+lo(reg.ax));
   currentdrive := w
end;

{=============================}
procedure chdrive(x:drivetype);
{=============================}

{ Choose a new default drive.
  Parameter can have the form of 'A:', 'a:', 'A', or 'a'.
  Works under DOS Version 1.  Requires XXDISKERR above.   }

var reg : rtype;

begin
   reg.ax := $0E00;
   reg.dx := ord(upcase(x[1])) - ord('A');
   intr($21,reg);
   if (reg.dx < 0) or (lo(reg.ax) < lo(reg.dx)) then xxdiskerr(x);
end;

{====================================}
function diskspace(x:drivetype): real;
{====================================}

{ Return number of bytes available on specified disk.
  Parameter can have the form of 'A:', 'a:', 'A', or 'a'.
  Requires XXDISKERR above.   }

var reg : rtype;

begin
   reg.ax := $3600;
   reg.dx := 1 + ord(upcase(x[1])) - ord('A');
   intr($21,reg);
   if (reg.ax = $ffff) then
      xxdiskerr(x)
   else
      diskspace := (256.0*hi(reg.dx)+lo(reg.dx))*reg.ax*reg.cx
end;

{=========================================}
function currentdir(x:drivetype): pathtype;
{=========================================}

{ Returns full path to active directory on specified drive,
  including backslash ath the beginning, not including
  drive designator.  Parameter as for CHDRIVE.
  Requires XXDISKERR above.   }

var w   : pathtype;
    reg : rtype;
    i   : integer;

begin
   { get current path }
   reg.ax := $4700;
   reg.dx := 1 + ord(upcase(x[1])) - ord ('A');
   reg.ds := seg(w[1]);
   reg.si := ofs(w[1]);
   intr($21,reg);
   if (reg.flags and 1) > 0 then xxdiskerr(x);

   { turn it into a Turbo string }
   i := 1;
   while w[i]<>chr(0) do begin
      w[i] := upcase(w[i]);
      i := i +1
      end;
   w[0] := chr(i-1);

   currentdir := '\' + w
end;

{=====================================}
procedure xxdir(x:pathtype; k:integer);
{=====================================}

{ Executes CHDIR, MKDIR, and RMDIR requests.
  Requires XXPAATHERR and CURRENTDRIVE, above. }

var w   : pathtype;
    reg : rtype;

begin
   w := x + chr(0);
   if w[2] <> ':' then { add drive designator }
      w := currentdrive + w;
   reg.ax := k;
   reg.ds := seg(w[1]);
   reg.dx := ofs(w[1]);
   intr($21,reg);
   if (reg.flags and 1) > 0 then xxpatherr(x)
end;

{==========================}
procedure chdir(x:pathtype);
{==========================}

{ Equivalent to CHDIR command in DOS.
  Requires XXDIR, XXPATHERR, and CURRENTDRIVE, above.
  Caution!  Do not leave a directory
  if you have files in it open.
}
begin
   xxdir(x,$3800)
end;

{==========================}
procedure rmdir(x:pathtype);
{==========================}

{ Equivalent to RMDIR command in DOS.
  Requires XXDIR, XXPATHERR, and CURRENTDRIVE, above.
}
begin
   xxdir(x,$3A00)
end;

{==========================}
procedure mkdir(x:pathtype);
{==========================}

{ Equivalent to MKDIR command in DOS.
  Requires XXDIR, XXPATHERR, and CURRENTDRIVE, above.
}
begin
   xxdir(x,$3900)
end;

{=============================}
procedure rename(x,y:pathtype);
{=============================}

{ Rename a file; unlike the DOS RENAME command,
  both parameters of this command are full paths.
  The paths need not be the same, allowing a file
  to be moved from one directory to another.
  First parameter can specify a drive; any drive
  letter on the second parameter is ignored.
}
var wx, wy : pathtype;
    reg    : rtype;

begin
   wx := x + chr(0);
   wy := y + chr(0);
   if wx[2]<>':' then wx := currentdrive + wx;
   reg.ax := $5600;
   reg.ds := seg(wx[1]);
   reg.dx := ofs(wx[1]);
   reg.es := seg(wy[1]);
   reg.di := ofs(wy[1]);
   intr($21,reg);
   if (reg.flags and 1) <> 0 then begin
      writeln('Error -- invalid rename request');
      writeln('      -- From: ''',x,'''');
      writeln('      -- To:   ''',y,'''');
      halt
      end
end;